home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_analog.idb / usr / freeware / bin / anlgform.pl.z / anlgform.pl
Perl Script  |  2002-07-08  |  8KB  |  218 lines
  1. #!/usr/freeware/bin/perl -T
  2. ###
  3. ###              analog 5.23             http://www.analog.cx/
  4. ### This program is copyright (c) Stephen R. E. Turner 1995 - 2002 except as
  5. ### stated otherwise. Distribution, usage and modification of this program is
  6. ### subject to the conditions of the Licence which you should have received
  7. ### with it. This program comes with no warranty, expressed or implied.
  8. ### Remember: Even the most carefully-designed CGI programs can accidentally
  9. ### have serious security bugs! See docs/form.html for notes on security
  10. ### design.
  11. ###
  12. ### anlgform.pl; the cgi front end for analog
  13.  
  14. # 1) uncomment (remove everything before $analog) and edit one of the next two
  15. #    lines to give the location (full pathname) of the analog executable.
  16. #       Unix: $analog = '/usr/local/etc/httpd/analog-5.23/analog';
  17. #       Windows: $analog = 'C:\program files\analog 5.23\analog.exe';
  18. $analog = '/usr/freeware/bin/analog';
  19. # 2) If you're on Unix, edit the first line in this file to give the location
  20. #    of Perl (don't remove the #! though).
  21. # 3) You also need to edit anlgform.html if you want to use the form.
  22. # 4) Add to the forbidden commands below if you want.
  23.  
  24. @forbidden = qw(LOGFORMAT APACHELOGFORMAT DEFAULTLOGFORMAT
  25.         APACHEDEFAULTLOGFORMAT HEADERFILE FOOTERFILE UNCOMPRESS
  26.         OUTFILE CACHEOUTFILE LOCALCHARTDIR ERRFILE DNS CGI
  27.         SETTINGS PROGRESSFREQ LANGFILE DESCFILE);
  28. # Forbidden commands: sysadmin can add more (must be in upper case!)
  29. # Other commands you might consider adding, because they allow users to
  30. # specify which files to use for the analysis, are LOGFILE and DOMAINSFILE.
  31. # If you add a command, you must also add any aliases it possesses.
  32. # There is a discussion of all this in docs/form.html.
  33.  
  34. @allowed = qw();
  35. # Allowed commands. If there are _any_ commands listed here, then _only_
  36. # commands which are in @allowed, and not in @forbidden, can be used.
  37.  
  38. require 5.001;
  39. use CGI;
  40.  
  41. # 1) INITIALISATION
  42. # delete all dangerous environment variables
  43. $ENV{PATH} = '';  # blank, not deleted, so that UNCOMPRESS doesn't get a path
  44. delete @ENV{qw/IFS CDPATH ENV BASH_ENV/};
  45. $query = new CGI;
  46. $|=1;
  47. $lt = localtime;
  48. $progname = $0 || 'anlgform.pl';
  49. if (($^O =~ /win32/i || $^O =~ /^win/i) && Win32::GetShortPathName($analog)) {
  50.     $analog = Win32::GetShortPathName($analog);
  51. }
  52.  
  53. # coerce query keys to caps in a new (key, pointer to array) hash called args
  54. # also remember the order the keys arrived in, as far as possible
  55. foreach $p ($query->param) {
  56.     foreach $a ($query->param($p)) {
  57.     checkchars($a);
  58.     push(@order, "\U$p") unless ($args{"\U$p"});
  59.     push(@{$args{"\U$p"}}, $a);
  60.     }
  61. }
  62.  
  63. # check LOGFILE and CACHEFILE only contain safe chars (see comments below)
  64. checkfilechars("LOGFILE");
  65. checkfilechars("CACHEFILE");
  66.  
  67. # 2) OPEN THE ANALOG PROCESS
  68. # qv=1 causes args to go straight to stdout, not program
  69. if (${$args{'QV'}}[-1] && !forbidden('QV')) {
  70.     print "Content-Type: text/plain\n\n";
  71.     open(ANALOG, ">-");
  72. }
  73. elsif (!$analog) {
  74.     badreq(500, "Program Incorrectly Configured",
  75.        "Can't run analog because anlgform.pl not set up properly.\n",
  76.        "See the server's error log for more details.");
  77.     print STDERR "[$lt] $progname: Can't run analog because the variable \$analog was not set: read the setup instructions!\n";
  78.     die;
  79. }
  80. elsif (!(-x $analog)) {
  81.     badreq(500, "Program Incorrectly Configured", "Can't run analog.",
  82.        "See the server's error log for more details.");
  83.     print STDERR "[$lt] $progname: Can't run analog because \"$analog\" not found or not executable";
  84.     print STDERR ": $!" if ($!);
  85.     print STDERR ".\n";
  86.     die;
  87. }
  88. else {
  89.     open (ANALOG, "|$analog +g-");  # errors here will get caught on close
  90. }
  91.  
  92. # 3) PRINT ALL THE COMMANDS
  93. # Special cases: must come first
  94. printargs('CG', 'CONFIGFILE') unless forbidden('CG');
  95. # both 'CG' and 'CONFIGFILE' must be allowed for this to happen.
  96. print ANALOG "CGI ON\nDNS NONE\nWARNINGS FL\n";
  97. printargs('WARNINGS');
  98. printargs('LOGTIMEOFFSET');
  99. foreach $k (@order) {
  100.     printargs($k)
  101.         unless($k eq 'QV' || $k eq 'CG' || $k eq 'CM' || $k =~ /FLOORB$/ ||
  102.            $k =~ /2$/ || $k =~ '^LOGTIMEOFFSET' || $k =~ '^WARNINGS' ||
  103.                # commands dealt with elsewhere
  104.                $k =~ /[^A-Z12]/ || $k eq '' || $k =~ /^IGNORE/);
  105.                # other stuff not wanted
  106. }
  107. # Special cases: must come last
  108. print ANALOG "DEBUG -C\n";
  109. printargs('CM', 'CONFIGFILE') unless forbidden('CM');
  110. # again, both 'CM' and 'CONFIGFILE' must be allowed for this to happen.
  111. print ANALOG "OUTFILE stdout\n";
  112.  
  113. # 4) WAIT FOR PROCESS TO FINISH. THAT'S IT.
  114. unless (close(ANALOG)) {
  115.     badreq(500, "Program Failure", 
  116.        "Analog failed to run or returned an error code.",
  117.        "Maybe your server's error log will give a clue why.");
  118.     print STDERR "[$lt] $progname: \"$analog\" failed to run or returned an error code";
  119.     print STDERR ": $!" if ($!);
  120.     print STDERR ".\n";
  121.     die;
  122. }
  123.  
  124.  
  125. ### SUBROUTINES 
  126. # A) IS A GIVEN COMMAND FORBIDDEN?
  127. sub forbidden {
  128.     return (grep($_[0] eq $_, @forbidden) ||
  129.         (@allowed && !grep($_[0] eq $_, @allowed)));
  130. }
  131.  
  132. # B) PRINT ONE COMMAND
  133. sub printargs {
  134.     my($is_floora) = 0;
  135.     my($is_12) = 0;
  136.     my($name) = $_[1] || $_[0];
  137.     if ($name =~ /FLOORA$/) {
  138.     chop($name);
  139.     $is_floora = 1;
  140.     }
  141.     elsif ($name =~ /1$/) {
  142.     chop($name);
  143.     $is_12 = 1;
  144.     }
  145.     return if forbidden($name);
  146.  
  147.     if ($is_floora) {
  148.     $a = ${$args{$name . 'A'}}[-1];  # last "FLOORA=$a" form arg specified
  149.     $b = ${$args{$name . 'B'}}[-1];
  150.     print ANALOG ("$name $a$b\n") if ($b ne '' && $b !~ /\\$/);
  151.     # could bracket $a$b, but no help because any special character in a
  152.     # FLOOR command is junk anyway.
  153.     }
  154.     elsif ($is_12) {
  155.     $a = ${$args{$name . '1'}}[-1];
  156.     $b = ${$args{$name . '2'}}[-1];
  157.     print ANALOG ("$name ", bracket($a), " ", bracket($b), "\n")
  158.         if ($b ne '');
  159.     }
  160.     else {
  161.     foreach $a (@{$args{$_[0]}}) {  # run through all "NAME=$a" form args
  162.         if ($a ne '') {
  163.         print ANALOG ("$name ", bracket($a), "\n");
  164.         print ANALOG ("DNS READ\n") if ($name eq 'DNSFILE');
  165.         }
  166.     }
  167.     }
  168. }
  169.  
  170. # C) PUT APPROPRIATE DELIMITERS ROUND AN ARGUMENT CONTAINING SPACES
  171. sub bracket {
  172.     local $_ = $_[0];
  173.     return $_ unless (/[\s\#]/ || /^['"\(]/ || /\\$/);
  174.     return "\"$_\"" unless (/"/);
  175.     return "'$_'" unless (/'/);
  176.     return "($_)";
  177.     # analog has no syntax if string contains ) as well as space, ' and "
  178. }
  179.  
  180. # D) CHECK ONLY SAFE CHARACTERS in LOGFILEs and CACHEFILEs. See docs/form.html.
  181. sub checkfilechars {
  182.     local ($_);
  183.     foreach (@{$args{$_[0]}}, @{$args{$_[0] . '1'}}) {
  184.     if (m([^\w. /\\:\-*?]) || m(\B-|-\B)) {
  185.         # i.e. contains a non-approved character, or a dash not
  186.         # between \w's. NB \w includes underscore.
  187.         badreq(403, "Illegal Request", "Unsafe characters in $_[0].");
  188.         printf STDERR "[$lt] $progname: Unsafe characters in \"$_[0] $_\" on request from %s\n", $ENV{REMOTE_HOST}?$ENV{REMOTE_HOST}:($ENV{REMOTE_ADDR}?$ENV{REMOTE_ADDR}:"unknown host");
  189.         die;
  190.     }
  191.     }
  192. }
  193.  
  194. # E) CHECK NO UNSAFE CHARACTERS IN OTHER COMMANDS. Again, see docs/form.html.
  195. sub checkchars {
  196.     local $_ = $_[0];
  197.     if (/[\x00-\x1F\x7F-\x9F]/) {
  198.     badreq(403, "Illegal Request", "Unsafe characters in \U$p.");
  199.     printf STDERR "[$lt] $progname: Unsafe characters in \"\U$p\E $_\" on request from %s\n", $ENV{REMOTE_HOST}?$ENV{REMOTE_HOST}:($ENV{REMOTE_ADDR}?$ENV{REMOTE_ADDR}:"unknown host");
  200.     die;
  201.     }
  202. }
  203.  
  204. # F) PRINT OUT ERROR MESSAGE
  205. sub badreq {
  206.     my($i);
  207.     print "Content-Type: text/html\n";
  208.     print "Status: $_[0] $_[1]\n\n";
  209.     print '<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">';
  210.     print "\n<html><head><title>$_[0] $_[1]</title></head>\n";
  211.     print "<body><h1>$_[1]</h1>\n";
  212.     for ($i = 2; defined($_[$i]); $i++) {
  213.     print "<br>" if ($i >= 3);
  214.     print "$_[$i]\n";
  215.     }
  216.     print "</body></html>\n";
  217. }
  218.